home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / modes / hideshow.el.z / hideshow.el
Encoding:
Text File  |  1998-05-21  |  17.5 KB  |  493 lines
  1. ;;; hideshow.el --- minor mode cmds to selectively display blocks of code
  2.  
  3. ;; Copyright (C) 1994,1995,1996 Free Software Foundation
  4.  
  5. ;; Author: Thien-Thi Nguyen <ttn@netcom.com>
  6. ;; Version: 3.4
  7. ;; Keywords: C C++ lisp tools editing
  8. ;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning
  9.  
  10. ;; This file is part of XEmacs.
  11.  
  12. ;; XEmacs is free software; you can redistribute it and/or modify it
  13. ;; under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2 of the License, or
  15. ;; (at your option) any later version.
  16.  
  17. ;; XEmacs is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25. ;; 02111-1307, USA.
  26.  
  27. ;;; Synched up with: FSF 19.34.
  28.  
  29. ;; LCD Archive Entry:
  30. ;; hideshow|Thien-Thi Nguyen|ttn@netcom.com|
  31. ;; minor mode commands to selectively display blocks of code|
  32. ;; 18-Oct-1994|3.4|~/modes/hideshow.el.Z|
  33.  
  34. ;;; Commentary:
  35.  
  36. ;; This file provides `hs-minor-mode'.  When active, six commands:
  37. ;;   hs-{hide,show}-{all,block}, hs-show-region and hs-minor-mode
  38. ;; are available.  They implement block hiding and showing.  Blocks are
  39. ;; defined in mode-specific way.  In c-mode or c++-mode, they are simply
  40. ;; curly braces, while in lisp-ish modes they are parens.  Multi-line
  41. ;; comments (c-mode) can also be hidden.  The command M-x hs-minor-mode
  42. ;; toggles the minor mode or sets it (similar to outline minor mode).
  43. ;; See documentation for each command for more info.
  44. ;;
  45. ;; The variable `hs-unbalance-handler-method' controls hideshow's behavior
  46. ;; in the case of "unbalanced parentheses".  See doc for more info.
  47. ;;
  48. ;; 30 May 1997    Pete Ware (ware@cis.ohio-state.edu)
  49. ;;    * Modified to use easymenu interface.
  50. ;;    * Removed tests for XEmacs vs GNU Emacs
  51. ;;    * Got it to work under XEmacs
  52.  
  53. ;; Suggested usage:
  54.  
  55. ;; (load-library "hideshow")
  56. ;; (defun my-hs-setup () "enables hideshow and binds some commands"
  57. ;;   (hs-minor-mode 1)
  58. ;;   (define-key hs-minor-mode-map "\C-ch" 'hs-hide-block)
  59. ;;   (define-key hs-minor-mode-map "\C-cs" 'hs-show-block)
  60. ;;   (define-key hs-minro-mode-map "\C-cH" 'hs-hide-all)
  61. ;;   (define-key hs-minro-mode-map "\C-cS" 'hs-show-all)
  62. ;;   (define-key hs-minor-mode-map "\C-cR" 'hs-show-region))
  63. ;; (add-hook 'X-mode-hook 'my-hs-setup t)   ; other modes similarly
  64. ;;
  65. ;; where X = {emacs-lisp,c,c++,perl,...}.  See the doc for the variable
  66. ;; `hs-special-modes-alist' if you'd like to use hideshow w/ other modes.
  67.  
  68. ;; Etc:
  69.  
  70. ;; Bug reports and fixes welcome (comments, too).  Thanks go to
  71. ;;    Dean Andrews <adahome@ix.netcom.com>
  72. ;;    Preston F. Crow <preston.f.crow@dartmouth.edu>
  73. ;;    Gael Marziou <gael@gnlab030.grenoble.hp.com>
  74. ;;    Keith Sheffield <sheff@edcsgw2.cr.usgs.gov>
  75. ;;    Jan Djarv <jan.djarv@sa.erisoft.se>
  76. ;;    Lars Lindberg <qhslali@aom.ericsson.se>
  77. ;;    Alf-Ivar Holm <alfh@ifi.uio.no>
  78. ;; for valuable feedback, code and bug reports.
  79.  
  80. ;;; Code:
  81.  
  82. (require 'easymenu)
  83.  
  84. ;;;----------------------------------------------------------------------------
  85. ;;; user-configurable variables
  86.  
  87. (defgroup hideshow nil
  88.   "Selectively display blocks of code."
  89.   :prefix "hs-"
  90.   :group 'outlines
  91.   :group 'tools)
  92.  
  93.  
  94. ;;;###autoload
  95. (defcustom hs-minor-mode nil
  96.   "Non-nil if using hideshow mode as a minor mode of some other mode.
  97. Use the command `hs-minor-mode' to toggle this variable."
  98.   :type 'boolean
  99.   :set (lambda (symbol value)
  100.      (hs-minor-mode (or value 0)))
  101.   :initialize 'custom-initialize-default
  102.   :require 'hideshow
  103.   :group 'hideshow)
  104.  
  105. (defcustom hs-unbalance-handler-method 'top-level
  106.   "*Symbol representing how \"unbalanced parentheses\" should be handled.
  107. This error is usually signaled by `hs-show-block'.  One of four values:
  108. `top-level', `next-line', `signal' or `ignore'.  Default is `top-level'.
  109.  
  110. - `top-level' -- Show top-level block containing the currently troublesome
  111.         block.
  112. - `next-line' -- Use the fact that, for an already hidden block, its end
  113.         will be on the next line.  Attempt to show this block.
  114. - `signal' -- Pass the error through, stopping execution.
  115. - `ignore' -- Ignore the error, continuing execution.
  116.  
  117. Values other than these four will be interpreted as `signal'."
  118.   :type '(radio (const :tag "Show top-level block" top-level)
  119.         (const :tag "Show block to next line" next-line)
  120.         (sexp :format "%t\n" :tag "Signal the error" signal)
  121.         (const :tag "Ignore the error" ignore))
  122.   :group 'hideshow)
  123.  
  124. (defcustom hs-special-modes-alist '((c-mode "{" "}")
  125.                  (c++-mode "{" "}"))
  126.   "*Alist of the form (MODE START-RE END-RE FORWARD-SEXP-FUNC).
  127. If present, hideshow will use these values for the start and end regexps,
  128. respectively.  Since Algol-ish languages do not have single-character
  129. block delimiters, the function `forward-sexp' which is used by hideshow
  130. doesn't work.  In this case, if a similar function is provided, you can
  131. register it and have hideshow use it instead of `forward-sexp'.  To add
  132. more values, use
  133.  
  134. \t(pushnew '(new-mode st-re end-re function-name)
  135. \t    hs-special-modes-alist :test 'equal)
  136.  
  137. For example:
  138.  
  139. \t(pushnew '(simula-mode \"begin\" \"end\" simula-next-statement)
  140. \t    hs-special-modes-alist :test 'equal)
  141.  
  142. Note that the regexps should not contain leading or trailing whitespace."
  143.   :type 'sexp ; too hard to do right
  144.   :group 'hideshow)
  145.  
  146. (defcustom hs-hide-hook nil
  147.   "*Hooks called at the end of `hs-hide-all' and `hs-hide-block'."
  148.   :type 'hook
  149.   :group 'hideshow)
  150.  
  151. (defcustom hs-show-hook nil
  152.   "*Hooks called at the end of commands to show text.
  153. These commands include `hs-show-all', `hs-show-block' and `hs-show-region'."
  154.   :type 'hook
  155.   :group 'hideshow)
  156.  
  157. (defcustom hs-minor-mode-prefix "\C-c"
  158.   "*Prefix key to use for hideshow commands in hideshow minor mode."
  159.   :type 'hook
  160.   :group 'hideshow)
  161.  
  162.  
  163. ;;;----------------------------------------------------------------------------
  164. ;;; internal variables
  165.  
  166.  
  167. (defvar hs-minor-mode-map (make-sparse-keymap)
  168.   "Mode map for hideshow minor mode.")
  169.  
  170. (easy-menu-define
  171.  hs-minor-mode-menu hs-minor-mode-map "Menu for hideshow minor mode"
  172.  '("Hideshow"
  173.     ["Hide Block" hs-hide-block t]
  174.     ["Show Block" hs-show-block t]
  175.     ["Hide All" hs-hide-all t]
  176.     ["Show All" hs-show-all t]
  177.     ["Show Region" hs-show-region t]))
  178.  
  179. (defvar hs-c-start-regexp nil
  180.   "Regexp for beginning of comments.  Buffer-local.
  181. Differs from mode-specific comment regexps in that surrounding
  182. whitespace is stripped.")
  183.  
  184. (defvar hs-c-end-regexp nil
  185.   "Regexp for end of comments.  Buffer-local.
  186. See `hs-c-start-regexp'.")
  187.  
  188. (defvar hs-block-start-regexp nil
  189.   "Regexp for beginning of block.  Buffer-local.")
  190.  
  191. (defvar hs-block-end-regexp nil
  192.   "Regexp for end of block.  Buffer-local.")
  193.  
  194. (defvar hs-forward-sexp-func 'forward-sexp
  195.   "Function used to do a forward-sexp.  Should change for Algol-ish modes.
  196. For single-character block delimiters -- ie, the syntax table regexp for the
  197. character is either `(' or `)' -- `hs-forward-sexp-func' would just be
  198. `forward-sexp'.  For other modes such as simula, a more specialized function
  199. is necessary.")
  200.  
  201. ;;;----------------------------------------------------------------------------
  202. ;;; support funcs
  203.  
  204. ;; snarfed from outline.el, but added buffer-read-only
  205. (defun hs-flag-region (from to flag)
  206.   "Hides or shows lines from FROM to TO, according to FLAG.
  207. If FLAG is `?\\n' (the newline character) then show the text;
  208. if FLAG is `?\\^M' \(control-M) then hide the text."
  209.   (let ((modp (buffer-modified-p))
  210.     buffer-read-only)        ; nothing is immune
  211.     (unwind-protect (progn
  212.               (subst-char-in-region
  213.                from to
  214.                (if (= flag ?\n) ?\C-m ?\n)
  215.                flag t))
  216.       (set-buffer-modified-p modp))))
  217.  
  218. (defun hs-hide-block-at-point (&optional end)
  219.   "Hide block iff on block beginning, optional END means reposition at end." 
  220.   (if (looking-at hs-block-start-regexp)
  221.       (let* ((p (point))
  222.          (q (progn (funcall hs-forward-sexp-func 1) (point))))
  223.     (forward-line -1) (end-of-line)
  224.     (if (and (< p (point)) (> (count-lines p q) 1))
  225.         (hs-flag-region p (point) ?\C-m))
  226.     (goto-char (if end q p)))))
  227.  
  228. (defun hs-show-block-at-point (&optional end)
  229.   "Show block iff on block beginning.  Optional END means reposition at end."
  230.   (if (looking-at hs-block-start-regexp)
  231.       (let* ((p (point))
  232.          (q
  233.           (condition-case error    ; probably unbalanced paren
  234.           (progn
  235.             (funcall hs-forward-sexp-func 1)
  236.             (point))
  237.         (error
  238.          (cond
  239.           ((eq hs-unbalance-handler-method 'ignore)
  240.            ;; just ignore this block
  241.            (point))
  242.           ((eq hs-unbalance-handler-method 'top-level)
  243.            ;; try to get out of rat's nest and expose the whole func
  244.            (if (/= (current-column) 0) (beginning-of-defun))
  245.            (setq p (point))
  246.            (re-search-forward (concat "^" hs-block-start-regexp)
  247.                       (point-max) t 2)
  248.            (point))
  249.           ((eq hs-unbalance-handler-method 'next-line)
  250.            ;; assumption is that user knows what s/he's doing
  251.            (beginning-of-line) (setq p (point))
  252.            (end-of-line 2) (point))
  253.           (t
  254.            ;; pass error through -- this applies to `signal', too
  255.            (signal (car error) (cdr error))))))))
  256.     (hs-flag-region p q ?\n)
  257.     (goto-char (if end (1+ (point)) p)))))
  258.  
  259. (defun hs-safety-is-job-n ()
  260.   "Warn if `selective-display' or `selective-display-ellipses' is nil."
  261.   (let ((str ""))
  262.     (or selective-display
  263.     (setq str "selective-display nil "))
  264.     (or selective-display-ellipses
  265.     (setq str (concat str "selective-display-ellipses nil")))
  266.     (if (= (length str) 0)
  267.     nil
  268.       (message "warning: %s" str)
  269.       (sit-for 2))))
  270.  
  271. (defun hs-inside-comment-p ()
  272.   "Returns non-nil if point is inside a comment, otherwise nil.
  273. Actually, for multi-line-able comments, returns a list containing
  274. the buffer position of the start and the end of the comment."
  275.   ;; is it single-line-only or multi-line-able?
  276.   (save-excursion
  277.     (let ((p (point))
  278.       q)
  279.       (if (string= comment-end "")    ; single line
  280.       (let (found)
  281.         (beginning-of-line)
  282.         (setq found (re-search-forward hs-c-start-regexp p t))
  283.         (and found (not (search-forward "\"" p t))))
  284.     (re-search-forward hs-c-end-regexp (point-max) 1)
  285.     (setq q (point))
  286.     (forward-comment -1)
  287.     (re-search-forward hs-c-start-regexp (point-max) 1)
  288.     (if (< (- (point) (length comment-start)) p)
  289.         (list (match-beginning 0) q)))))) 
  290.  
  291. (defun hs-grok-mode-type ()
  292.   "Setup variables for new buffers where applicable."
  293.   (if (and (boundp 'comment-start)
  294.        (boundp 'comment-end))
  295.       (progn
  296.     (setq hs-c-start-regexp (regexp-quote comment-start))
  297.     (if (string-match " +$" hs-c-start-regexp)
  298.         (setq hs-c-start-regexp
  299.           (substring hs-c-start-regexp 0 (1- (match-end 0)))))
  300.     (setq hs-c-end-regexp (if (string= "" comment-end) "\n"
  301.                 (regexp-quote comment-end)))
  302.     (if (string-match "^ +" hs-c-end-regexp)
  303.         (setq hs-c-end-regexp
  304.           (substring hs-c-end-regexp (match-end 0))))
  305.     (let ((lookup (assoc major-mode hs-special-modes-alist)))
  306.       (setq hs-block-start-regexp (or (nth 1 lookup) "\\s\(")
  307.         hs-block-end-regexp (or (nth 2 lookup) "\\s\)")
  308.         hs-forward-sexp-func (or (nth 3 lookup) 'forward-sexp))))))
  309.  
  310. (defun hs-find-block-beginning ()
  311.   "Repositions point at block-start.  Return point, or nil if top-level." 
  312.   (let (done
  313.     (here (point))
  314.     (both-regexps (concat "\\(" hs-block-start-regexp "\\)\\|\\("
  315.                   hs-block-end-regexp "\\)")))
  316.     (while (and (not done)
  317.         (re-search-backward both-regexps (point-min) t))
  318.       (if (match-beginning 1)        ; start of start-regexp
  319.       (setq done (match-beginning 1))
  320.     (goto-char (match-end 2))    ; end of end-regexp
  321.     (funcall hs-forward-sexp-func -1)))
  322.     (goto-char (or done here))
  323.     done))
  324.  
  325. (defmacro hs-life-goes-on (&rest body)
  326.   "Executes optional BODY iff variable `hs-minor-mode' is non-nil."
  327.   (list 'if 'hs-minor-mode (cons 'progn body)))
  328.  
  329.  
  330. ;;;----------------------------------------------------------------------------
  331. ;;; commands
  332.  
  333. ;;;###autoload
  334. (defun hs-hide-all ()
  335.   "Hides all top-level blocks, displaying only first and last lines.
  336. It moves point to the beginning of the line, and it runs the normal hook
  337. `hs-hide-hook'.  See documentation for `run-hooks'."
  338.   (interactive)
  339.   (hs-life-goes-on
  340.    (message "hiding all blocks ...")
  341.    (save-excursion
  342.      (hs-flag-region (point-min) (point-max) ?\n) ; eliminate weirdness
  343.      (goto-char (point-min))
  344.      (let ((count 0)
  345.        (top-level-re (concat "^" hs-block-start-regexp)))
  346.        (while (progn
  347.         (forward-comment (buffer-size))
  348.         (re-search-forward top-level-re (point-max) t))
  349.      (goto-char (match-beginning 0))
  350.      (hs-hide-block-at-point t)
  351.      (message "hiding ... %d" (setq count (1+ count)))))
  352.      (hs-safety-is-job-n))
  353.    (beginning-of-line)
  354.    (message "hiding all blocks ... done")
  355.    (run-hooks 'hs-hide-hook)))
  356.  
  357. (defun hs-show-all ()
  358.   "Shows all top-level blocks.
  359. This does not change point; it runs the normal hook `hs-show-hook'.
  360. See documentation for `run-hooks'."
  361.   (interactive)
  362.   (hs-life-goes-on
  363.    (message "showing all blocks ...")
  364.    (hs-flag-region (point-min) (point-max) ?\n)
  365.    (message "showing all blocks ... done")
  366.    (run-hooks 'hs-show-hook)))
  367.  
  368. ;;;###autoload
  369. (defun hs-hide-block (&optional end)
  370.   "Selects a block and hides it.  With prefix arg, reposition at end.
  371. Block is defined as a sexp for lispish modes, mode-specific otherwise.
  372. Comments are blocks, too.  Upon completion, point is at repositioned and
  373. the normal hook `hs-hide-hook' is run.  See documentation for `run-hooks'."
  374.   (interactive "P")
  375.   (hs-life-goes-on
  376.    (let ((c-reg (hs-inside-comment-p)))
  377.      (if c-reg
  378.      (cond ((string= comment-end "")
  379.         (message "can't hide a single-line comment"))
  380.            ((< (count-lines (car c-reg) (nth 1 c-reg)) 2)
  381.         (message "not enough comment lines to hide"))
  382.            (t
  383.         (goto-char (nth 1 c-reg))
  384.         (forward-line -1)
  385.         (hs-flag-region (car c-reg) (point) ?\C-m)
  386.         (goto-char (if end (nth 1 c-reg) (car c-reg)))
  387.         (hs-safety-is-job-n)
  388.         (run-hooks 'hs-hide-hook)))
  389.        (if (or (looking-at hs-block-start-regexp)
  390.            (hs-find-block-beginning))
  391.        (progn
  392.          (hs-hide-block-at-point end)
  393.          (hs-safety-is-job-n)
  394.          (run-hooks 'hs-hide-hook)))))))
  395.  
  396. (defun hs-show-block (&optional end)
  397.   "Selects a block and shows it.  With prefix arg, reposition at end.
  398. Upon completion, point is repositioned and the normal hook
  399. `hs-show-hook' is run.  See documentation for `hs-hide-block' and `run-hooks'."
  400.   (interactive "P")
  401.   (hs-life-goes-on
  402.    (let ((c-reg (hs-inside-comment-p)))
  403.      (if c-reg
  404.      (cond ((string= comment-end "")
  405.         (message "already looking at the entire comment"))
  406.            (t
  407.         (hs-flag-region (car c-reg) (nth 1 c-reg) ?\n)
  408.         (goto-char (if end (nth 1 c-reg) (car c-reg)))))
  409.        (if (or (looking-at hs-block-start-regexp)
  410.            (hs-find-block-beginning))
  411.        (progn
  412.          (hs-show-block-at-point end)
  413.          (hs-safety-is-job-n)
  414.          (run-hooks 'hs-show-hook)))))))
  415.  
  416. (defun hs-show-region (beg end)
  417.   "Shows all lines from BEG to END, without doing any block analysis.
  418. Note:` hs-show-region' is intended for use when when `hs-show-block' signals
  419. `unbalanced parentheses' and so is an emergency measure only.  You may
  420. become very confused if you use this command indiscriminately."
  421.   (interactive "r")
  422.   (hs-life-goes-on
  423.    (hs-flag-region beg end ?\n)
  424.    (hs-safety-is-job-n)
  425.    (run-hooks 'hs-show-hook)))
  426.  
  427. ;;;###autoload
  428. (defun hs-minor-mode (&optional arg)
  429.   "Toggle hideshow minor mode.
  430. With ARG, turn hideshow minor mode on if ARG is positive, off otherwise.
  431. When hideshow minor mode is on, the menu bar is augmented with hideshow
  432. commands and the hideshow commands are enabled.  The variables
  433. `selective-display' and `selective-display-ellipses' are set to t.
  434. Last, the normal hook `hs-minor-mode-hook' is run; see the doc for `run-hooks'.
  435.  
  436. Turning hideshow minor mode off reverts the menu bar and the
  437. variables to default values and disables the hideshow commands."
  438.   (interactive "P")
  439.   (setq hs-minor-mode
  440.         (if (null arg)
  441.         (not hs-minor-mode)
  442.           (> (prefix-numeric-value arg) 0)))
  443.   (if hs-minor-mode
  444.       (progn
  445.     (easy-menu-add hs-minor-mode-menu hs-minor-mode-map)
  446.     (setq selective-display t
  447.           selective-display-ellipses t)
  448.     (hs-grok-mode-type)
  449.     (run-hooks 'hs-minor-mode-hook))
  450.     (easy-menu-remove hs-minor-mode-menu)
  451.     (kill-local-variable 'selective-display)
  452.     (kill-local-variable 'selective-display-ellipses)))
  453.  
  454.  
  455. ;;;----------------------------------------------------------------------------
  456. ;;; load-time setup routines
  457.  
  458. (if (fboundp 'add-minor-mode)
  459.     (progn
  460.       ;; XEmacs: need this for the change in add-minor-mode
  461.       ;; ### Why? -- pete@cis.ohio-state.edu
  462.       (fset 'hs-minor-mode-map hs-minor-mode-map)
  463.       (add-minor-mode 'hs-minor-mode " hs" 'hs-minor-mode-map))
  464.   ;;else
  465.   (or (assq 'hs-minor-mode minor-mode-map-alist)
  466.       (setq minor-mode-map-alist
  467.         (cons (cons 'hs-minor-mode hs-minor-mode-map)
  468.           minor-mode-map-alist)))
  469.   (or (assq 'hs-minor-mode minor-mode-alist)
  470.       (setq minor-mode-alist (append minor-mode-alist
  471.                      (list '(hs-minor-mode " hs"))))))
  472. ;; make some variables buffer-local
  473. (make-variable-buffer-local 'hs-minor-mode)
  474. (make-variable-buffer-local 'hs-c-start-regexp)
  475. (make-variable-buffer-local 'hs-c-end-regexp)
  476. (make-variable-buffer-local 'hs-block-start-regexp)
  477. (make-variable-buffer-local 'hs-block-end-regexp)
  478. (make-variable-buffer-local 'hs-forward-sexp-func)
  479. (put 'hs-minor-mode 'permanent-local t)
  480. (put 'hs-c-start-regexp 'permanent-local t)
  481. (put 'hs-c-end-regexp 'permanent-local t)
  482. (put 'hs-block-start-regexp 'permanent-local t)
  483. (put 'hs-block-end-regexp 'permanent-local t)
  484. (put 'hs-forward-sexp-func 'permanent-local t)
  485.  
  486.  
  487. ;;;----------------------------------------------------------------------------
  488. ;;; that's it
  489.  
  490. (provide 'hideshow)
  491.  
  492. ;;; hideshow.el ends here
  493.